Amiga Games 1996 December/Amiga Games 1996 #12.iso/rexx/arcdir.dopus5

Text File | 1996-08-11 | 23KB | 844 lines

/*
  $VER: ArcDir.dopus5 1.0 (11.8.96)
  Written by Edmund Vermeulen ([e-mail]).

  ARexx script for Directory Opus 5 to show the contents of an LhA or LZX
  archive in an Opus lister and operate on the files and directories inside
  the archive as if it is a normal directory.

  Function : ARexx      DOpus5:ARexx/ArcDir.dopus5 Browse {Qp} {f} {Ql}
  Flags : Run asynchronously
*/

parse arg cmd ' ' portname ' "' arcfile '" ' handle ' ' arcsubdir

address value portname
options results
options failat 21
signal on syntax
signal on halt
signal on break_c
lf='0a'x

dopus getfiletype '"'arcfile'"' id
arctype=result
if arctype~='LHA' & arctype~='LZX' then
   exit

if ~show('l','rexxsupport.library') then
   call addlib('rexxsupport.library',0,-30)

if exists('LIBS:locale.library') then do
   if ~show(l,'locale.library') then
      call addlib('locale.library',0,-30)
   catalog=opencatalog('ArcDir.catalog','english',0)
   end
else
   catalog=0

dopus version
newopus=result~='RESULT' & translate(result,'.',' ')>=5.1215

if upper(cmd)='BROWSE' | handle=0 then do
   lister new
   handle=result
   lister set handle source
   end
else
   lister empty handle

call arclist


/* Attach a handler to the lister and wait for an event to happen. */

handlername='ArcDir'handle
lister set handle handler handlername quotes
call openport(handlername)

viewcommands='Read HexRead Show Play'  /* you may add other Opus commands if you wish */
notsupported='CopyAs Move MoveAs Rename Comment Protect'
traps='Copy Delete MakeDir Parent Root ScanDir' viewcommands notsupported
do while traps~=''
   parse var traps trapcommand traps
   dopus addtrap trapcommand handlername
   end

thishandle=handle
lister set handle busy off

do until event='inactive'
   if waitpkt(handlername) then do

      packet=getpkt(handlername)
      if packet~='00000000'x then do

         event=getarg(packet,0)
         handle=getarg(packet,1)
         namestr=getarg(packet,2)
         user=getarg(packet,3)
         pathstr=getarg(packet,4)
         qualifier=getarg(packet,6)
         deststr=getarg(packet,7)

         if newopus then
            lister wait thishandle quick
         else do
            lister query thishandle busy
            if result=1 then
               call delay(10)
            end

         select
            when event='doubleclick' then do
               if left(namestr,1)='"' then
                  parse var namestr '"' namestr '"'
               if namestr='' then
                  fileinfo.type=1
               else
                  lister query handle entry '"'namestr'"' stem fileinfo.
               if fileinfo.type>0 then do  /* it's a dir */
                  if qualifier='shift' then do
                     lister new
                     newhandle=result
                     address command 'Copy >NIL: T:ArcDir.list'handle 'T:ArcDir.list'newhandle
                     lister set newhandle source
                     address command 'Run >NIL: <NIL: RX DOpus5:ARexx/ArcDir.dopus5 GETDIR' portname '"'arcfile'"' newhandle arcsubdir||namestr'/'
                     end
                  else do
                     arcsubdir=arcsubdir||namestr'/'
                     call arclist
                     end
                  end
               else
                  call viewsingle
               end

            when event='reread' | event='ScanDir' then do
               call delete('T:ArcDir.list'handle)
               call arclist
               end

            when event='path' then
               call dopath

            when event='drop' then do
               parse var namestr '"' droppath '"'
               if pos(right(droppath,1),'/:')>0 then  /* disk or left-out drawer */
                  lister read handle '"'droppath'"' force
               else do
                  parse var namestr '"' dropfile '"'
                  if pos(':',dropfile)=0 then do
                     lister query user path
                     dropfile=result||dropfile
                     end
                  dopus getfiletype '"'dropfile'"' id
                  if result='LHA' | result='LZX' then do
                     arctype=result
                     arcfile=dropfile
                     arcsubdir=''
                     call delete('T:ArcDir.list'handle)
                     call arclist
                     end
                  else do
                     allents=namestr
                     call getall
                     otherhandle=user
                     call arcadd
                     end
                  end
               end

            when event='dropfrom' then
               if qualifier='shift' then do
                  parse var namestr '"' namestr '"'
                  lister query handle entry '"'namestr'"' stem fileinfo.
                  if fileinfo.type>0 then do
                     address command 'Copy >NIL: T:ArcDir.list'handle 'T:ArcDir.list'user
                     address command 'Run >NIL: <NIL: RX DOpus5:ARexx/ArcDir.dopus5 GETDIR' portname '"'arcfile'"' user arcsubdir||namestr'/'
                     end
                  end
               else do
                  allents=namestr
                  call getall
                  otherhandle=user
                  call arcextract
                  end

            when upper(event)='PARENT' | upper(event)='ROOT' then
               call doparentroot

            when event='Delete' then
               call dodelete

            when event='MakeDir' then
               call domakedir

            when event='Copy' then do
               lister query handle selentries
               allents=result
               call getall
               if handle=thishandle then do
                  otherhandle=user
                  call arcextract
                  end
               else do
                  otherhandle=handle
                  handle=user
                  call arcadd
                  end
               end

            when pos(event,viewcommands)>0 then do
               lister query handle firstsel
               parse var result '"' namestr '"'
               lister select handle '"'namestr'"' off
               lister refresh handle
               call viewsingle
               end

            when pos(event,notsupported)>0 then do
               lister set handle busy on
               call displayerror(getcatstr(23,'Command not supported in ArcDir.'))
               lister set handle busy off
               end

            otherwise
               nop
            end

         lister set handle busy off
         call reply(packet,0)
         end
      end
   end

call delete('T:ArcDir.list'handle)
call closeport(handlername)
if catalog~=0 then
   call closecatalog(catalog)
exit


doparentroot:

   if arcsubdir='' then do
      cuthere=lastpos('/',arcfile)
      if cuthere=0 | upper(event)='ROOT' then
         cuthere=pos(':',arcfile)
      normaldir=left(arcfile,cuthere)
      if qualifier='shift' then do
         lister new normaldir
         newhandle=result
         lister wait newhandle
         lister set newhandle source
         end
      else do
         lister set handle title
         lister read handle normaldir
         end
      end
   else do
      if upper(event)='ROOT' then
         newsubdir=''
      else do
         cuthere=lastpos('/',left(arcsubdir,length(arcsubdir)-1))
         newsubdir=left(arcsubdir,cuthere)
         end
      if qualifier='shift' then do
         lister new
         newhandle=result
         address command 'Copy >NIL: T:ArcDir.list'handle 'T:ArcDir.list'newhandle
         lister set newhandle source
         address command 'Run >NIL: <NIL: RX DOpus5:ARexx/ArcDir.dopus5 GETDIR' portname '"'arcfile'"' newhandle newsubdir
         end
      else do
         arcsubdir=newsubdir
         call arclist
         end
      end
   return


dopath:

   if pos(right(namestr,1),'/:')=0 then
      namestr=namestr'/'
   if left(namestr,length(arcfile))=arcfile then do
      if namestr=arcfile'/'arcsubdir then
         call delete('T:ArcDir.list'handle)
      else
         arcsubdir=substr(namestr,length(arcfile)+2)
      call arclist
      end
   else do
      cuthere=pos('.LHA/',upper(namestr))
      if cuthere=0 then
         cuthere=pos('.LZH/',upper(namestr))
      if cuthere>0 then
         arctype='LHA'
      else do
         cuthere=pos('.LZX/',upper(namestr))
         if cuthere>0 then
            arctype='LZX'
         end
      if cuthere>0 then do
         call delete('T:ArcDir.list'handle)
         arcfile=left(namestr,cuthere+3)
         arcsubdir=substr(namestr,cuthere+5)
         call arclist
         end
      else do
         lister read handle '"'namestr'"' force
         end
      end
   return


dodelete:

   lister set handle busy on
   lister query handle selentries
   allents=result
   call getall
   if entries=0 then
      return

   lister query handle numselfiles
   nfiles=result
   lister query handle numseldirs
   ndirs=result
   call dorequest('"'getcatstr(5,'Warning: you cannot get back'lf||,
      'what you delete! OK to delete:'lf||lf'%s file(s) and'lf||,
      '%s drawer(s) (and their contents)?',nfiles,ndirs)'"',
      getcatstr(6,'Proceed|Cancel'))
   if ~rc then
      return

   lister set handle title getcatstr(7,'Deleting from archive...')
   lister refresh handle full

   select
      when arctype='LHA' then do
         call open('actionfile','T:actionfile'handle,'w')
         do i=1 to entries
            if type.i>0 then
               wild='/#?'
            else
               wild=''
            call writeln('actionfile','"'patch(arcsubdir||name.i,"'")||wild'"')
            end
         call close('actionfile')
         address command 'LhA d -q -X -Qp -Qo "'patch(arcfile)'" @T:actionfile'handle
         problem=rc>0
         address command 'Delete >NIL: T:LhA_ArcWork.#? QUIET'
         problem=problem | rc=0
         call delete('T:actionfile'handle)
         end
      when arctype='LZX' then do
         lzxcmd='LZX d -q -X0 --' lzxkludge(patch(arcfile))
         linelen=0
         n=0
         do i=1 to entries
            if type.i>0 then
               dothis=lzxkludge(patch(arcsubdir||name.i,'[')'/#?')
            else
               dothis=lzxkludge(patch(arcsubdir||name.i))
            linelen=linelen+length(dothis)+1
            if i=1 | linelen>255 then do
               n=n+1
               dothese.n=dothis
               linelen=length(lzxcmd)+length(dothis)+1
               end
            else
               dothese.n=dothese.n dothis
            end
         do i=1 to n
            address command lzxcmd dothese.i
            problem=rc>0
            if problem then
               leave
            end
         end
      end

   if problem then
      call displayerror(getcatstr(8,'Error while deleting from archive.'))
   else do
      call delete('T:ArcDir.list'handle)
      do i=1 to entries
         if name.i='' then do
            lister query handle separate
            if result='filesfirst' then do
               lister query handle numfiles
               entryno=result
               end
            else
               entryno=0
            lister remove handle '#'entryno
            end
         else
            lister remove handle '"'name.i'"'
         end
      end

   lister set handle title 'ArcDir:' arcname
   lister refresh handle full
   return


domakedir:

   lister set handle busy on
   dopus getstring '"'getcatstr(15,'Enter directory name')'" 31 ""' getcatstr(16,'OK|Cancel')
   dirtomake=result
   if dirtomake=='' | dirtomake='RESULT' then
      return

   now=date('i')*86400+time('s')
   call createdirs(dirtomake'/')

   select
      when arctype='LHA' then
         address command 'LhA a -q -e -r -X -Qo "'patch(arcfile)'" T:ArcDir'handle'/' '"'patch(arcsubdir||dirtomake,"'")'"'
      when arctype='LZX' then do
         oldcurrent=pragma('d')
         call pragma('d','T:ArcDir'handle)
         address command 'LZX a -q -e -r -X0 --' lzxkludge(patch(arcfile)) lzxkludge(patch(arcsubdir||dirtomake))
         call pragma('d',oldcurrent)
         end
      end

   if rc>0 then
      call displayerror(getcatstr(13,'Error while adding to archive.'))
   else do
      lister add handle '"'dirtomake'" -1 1' now '----rwed'
      lister refresh handle
      end

   address command 'Delete >NIL: T:ArcDir'handle 'ALL QUIET'
   call delete('T:ArcDir.list'handle)
   return


createdirs:

   parse arg subdir
   dirstocreate='T:ArcDir'handle'/'arcsubdir||subdir
   here=0
   do until here=0
      here=pos('/',dirstocreate,here+1)
      if here>0 then
         call makedir(left(dirstocreate,here-1))
      end
   return


arclist:

   lister set handle busy on
   lister clear handle
   lister set handle title getcatstr(1,'Listing archive...')
   lister set handle path arcfile'/'arcsubdir
   lister refresh handle full

   if ~exists(arcfile) then do
      call displayerror(getcatstr(22,'Error: archive not found'))
      return
      end

   if ~exists('T:ArcDir.list'handle) then do
      select
         when arctype='LHA' then
            address command 'LhA >T:ArcDir.list'handle 'vv -N -X -Qw -Qo "'arcfile'"'
         when arctype='LZX' then
            address command 'LZX >T:ArcDir.list'handle 'v -X0 --' lzxkludge(patch(arcfile))
         end
      if rc>0 then
         call displayerror(getcatstr(2,'Error while listing archive.'))
      end

   oldcurrent=pragma('d')
   call pragma('d','DOpus5:C')
   address command 'ArcDirList >T:ArcDir.list'handle'@ T:ArcDir.list'handle '"'patchstar(arcsubdir)'"'
   call pragma('d',oldcurrent)

   if ~open('tempfile','T:ArcDir.list'handle'@','r') then do
      call displayerror(getcatstr(24,'ArcDirList not found!'))
      return
      end
   thisline=readln('tempfile')
   do while thisline~=''
      lister add handle thisline
      thisline=readln('tempfile')
      end
   call close('tempfile')
   call delete('T:ArcDir.list'handle'@')

   cuthere=lastpos('/',arcfile)
   if cuthere=0 then
      cuthere=lastpos(':',arcfile)
   arcname=substr(arcfile,cuthere+1)
   lister set handle title 'ArcDir:' arcname
   lister refresh handle full
   return


arcextract:

   lister set handle busy on
   if otherhandle=0 then
      if newopus then
         winpath=deststr
      else do
         call displayerror(getcatstr(9,'No destination selected!'))
         return
         end
   else do
      if checkhandler() then
         return
      lister set otherhandle busy on
      lister query otherhandle path
      winpath=result
      end

   lister query handle numdirs
   anydirs=result>0
   mustmove=anydirs & arcsubdir~==''
   if mustmove then do
      destpath=winpath'ArcDir'handle
      call makedir(destpath)
      destpath=destpath'/'
      end
   else
      destpath=winpath

   lister set handle title getcatstr(10,'Extracting from archive...')
   lister refresh handle full

   select
      when arctype='LHA' then do
         call open('actionfile','T:actionfile'handle,'w')
         do i=1 to entries
            if type.i>0 then
               wild='/#?'
            else
               wild=''
            call writeln('actionfile','"'patch(arcsubdir||name.i,"'")||wild'"')
            end
         call close('actionfile')

         if anydirs then
            cmd='x'
         else
            cmd='e -x2'
         address command 'LhA' cmd '-q -a -C0 -X -Qo "'patch(arcfile)'" "'destpath'" @T:actionfile'handle
         problem=rc>0
         call delete('T:actionfile'handle)
         end
      when arctype='LZX' then do
         if anydirs then
            cmd='x'
         else
            cmd='e'
         lzxcmd='LZX' cmd '-q -a -C0 -X0 --' lzxkludge(patch(arcfile))

         linelen=0
         n=0
         do i=1 to entries
            if type.i>0 then
               dothis=lzxkludge(patch(arcsubdir||name.i,'[')'/#?')
            else
               dothis=lzxkludge(patch(arcsubdir||name.i))
            linelen=linelen+length(dothis)+1
            if i=1 | linelen>255 then do
               n=n+1
               dothese.n=dothis
               linelen=length(lzxcmd)+length(dothis)+1
               end
            else
               dothese.n=dothese.n dothis
            end

         oldcurrent=pragma('d')
         call pragma('d',destpath)
         do i=1 to n
            address command lzxcmd dothese.i
            problem=rc>0
            if problem>0 then
               leave
            end
         call pragma('d',oldcurrent)
         end
      end

   if problem then
      call displayerror(getcatstr(11,'Error while extracting from archive.'))
   else
      do i=1 to entries
         lister select handle '"'name.i'"' off
         end

   lister set handle title 'ArcDir:' arcname
   lister refresh handle full

   if mustmove then do
      address command 'DOpus5:C/Move >NIL: "'destpath||arcsubdir'#?" "'winpath'"'
      address command 'Delete >NIL: "'winpath'ArcDir'handle'" ALL QUIET'
      end

   if otherhandle~=0 then do
      lister set otherhandle busy off
      lister read otherhandle '"'winpath'"' force
      end
   return


arcadd:

   if checkhandler() then
      return
   lister set handle busy on
   lister set otherhandle busy on
   lister query otherhandle path
   frompath=result

   mustcopy=upper(right(src,length(arcsubdir)))~==upper(arcsubdir)
   if mustcopy then do
      homedir='T:ArcDir'handle'/'
      call createdirs
      end
   else
      homedir=left(frompath,length(frompath)-length(arcsubdir))

   if mustcopy then
      do i=1 to entries
         lister query otherhandle entry '"'name.i'"' stem fileinfo.
         if fileinfo.type>0 then
            address command 'Copy "'frompath||name.i'" "T:ArcDir'handle'/'arcsubdir||name.i'" ALL CLONE QUIET'
         else
            address command 'Copy "'frompath||name.i'" "T:ArcDir'handle'/'arcsubdir'" CLONE QUIET'
         end

   lister set handle title getcatstr(12,'Adding to archive...')
   lister refresh handle full

   select
      when arctype='LHA' then do
         call open('actionfile','T:actionfile'handle,'w')
         call writeln('actionfile','"'patch(homedir)'"')
         do i=1 to entries
            call writeln('actionfile','"'patch(arcsubdir||name.i)'"')
            end
         call close('actionfile')

         if pos('.LZH/',test)>0 then
            method='-0'
         else
            method=''
         address command 'LhA r' method '-q -e -r -X -Qo "'patch(arcfile)'" @T:actionfile'handle
         problem=rc>0
         call delete('T:actionfile'handle)
         end
      when arctype='LZX' then do
         lzxcmd='LZX u -q -a -e -r -X0 --' lzxkludge(patch(arcfile))
         linelen=0
         n=0
         do i=1 to entries
            if type.i>0 then
               dothis=lzxkludge(patch(arcsubdir||name.i,'[')'/#?')
            else
               dothis=lzxkludge(patch(arcsubdir||name.i))
            linelen=linelen+length(dothis)+1
            if i=1 | linelen>255 then do
               n=n+1
               dothese.n=dothis
               linelen=length(lzxcmd)+length(dothis)+1
               end
            else
               dothese.n=dothese.n dothis
            end

         oldcurrent=pragma('d')
         call pragma('d',homedir)
         do i=1 to n
            address command lzxcmd dothese.i
            problem=rc>0
            if problem then
               leave
            end
         call pragma('d',oldcurrent)
         end
      end

   if mustcopy then
      address command 'Delete >NIL: T:ArcDir'handle 'ALL QUIET'

   if problem then
      call displayerror(getcatstr(13,'Error while adding to archive.'))
   else do
      do i=1 to entries
         lister select otherhandle '"'name.i'"' off
         end
      lister refresh otherhandle
      call delete('T:ArcDir.list'handle)
      call arclist
      end

   lister set otherhandle busy off
   return


viewsingle:

   lister set handle busy on
   lister set handle title getcatstr(10,'Extracting from archive...')
   lister refresh handle full

   select
      when arctype='LHA' then
         address command 'LhA e -q -x2 -X -Qo "'patch(arcfile)'" T: "'patch(arcsubdir||namestr,"'")'"'
      when arctype='LZX' then
         address command 'LZX e -q -X0 --' lzxkludge(patch(arcfile)) 'T:' lzxkludge(patch(arcsubdir||namestr))
      end

   if rc>0 then
      call displayerror(getcatstr(11,'Error while extracting from archive.'))

   /* some creative ARexx programming :-) */
   address command 'Run >NIL: <NIL: RX',
      '"address' portname';',
      'thisfile=''T:'namestr''';',
      'command' event '''""''thisfile''""'';',
      'command wait protect name ''""''thisfile''""'' set RWED;',
      'do until ~exists(thisfile) | delete(thisfile);',
         'call delay(200);',
         'end"'

   lister set handle title 'ArcDir:' arcname
   lister refresh handle full
   return


getall:

   entries=0
   do while allents~=''
      entries=entries+1
      parse var allents '"' name.entries '"' allents
      if name.entries='' then
         type.entries=1
      else do
         lister query handle entry '"'name.entries'"' stem fileinfo.
         type.entries=fileinfo.type
         end
      end
   return


patch:  /* patch filenames containing strange characters */

   parse arg patched,extra
   strange='*#?|%()~'extra
   if arctype='LHA' then
      strange=strange'[]'
   pos=1
   do until here=0
      here=verify(substr(patched,pos),strange,'m')
      if here>0 then do
         pos=pos+here+1
         patched=insert("'",patched,pos-3)
         end
      end
   if arctype='LHA' & left(patched,1)='@' then
      patched='%'patched
   if arctype='LZX' then
      if length(patched)-lastpos('/',patched)>=30 then
         patched=patched'#?'
   return patched


patchstar:

   parse arg remain
   patched=''
   do until remain=''
      parse var remain before '*' remain
      patched=patched||before
      if remain~=='' then
         patched=patched'**'
      end
   return patched


lzxkludge:

   parse arg string
   if pos(' ',string)>0 then
      do while pos("'*",string)>0
         parse var string fore "'*" aft
         string=fore'?'aft
         end
   if pos('*',string)=0 then
      string='"'string'"'
   return string


getcatstr:

   parse arg msgno,msgstring
   if catalog~=0 then
      msgstring=getcatalogstr(catalog,msgno,msgstring)
   do i=3 to arg()
      parse var msgstring fore '%s' aft
      msgstring=fore||arg(i)||aft
      end
   return msgstring


checkhandler:

   lister query otherhandle handler
   return ~(result='RESULT' | result='')


syntax:

   call displayerror('Syntax Error' rc',' errortext(rc) 'in line' sigl'.')
   lister set thishandle busy off
   lister set otherhandle busy off
   exit


halt:
break_c:

   lister set thishandle handler
   lister clear thishandle
   lister set thishandle path
   lister set thishandle title 'ArcDir.dopus5 halted.'
   lister refresh thishandle full
   lister set thishandle title
   exit


displayerror:

   parse arg message
   lister set handle title message
   lister refresh handle full
   command flash
   call dorequest('"'message'"' getcatstr(4,'OK'))
   lister set handle title 'ArcDir:' arcname
   return


dorequest:

   parse arg reqargs
   if newopus then
      lister request handle reqargs
   else
      dopus request reqargs
   return